;;;;  $Id: fill.sld 46 2012-03-29 05:34:38Z alan.watson.f@gmail.com $
;;;;
;;;;  Copyright (c) Dorai Sitaram 1999-2010.
;;;;  Copyright (c) Alan Watson 2012.
;;;;
;;;; This program is licensed under version 3 of the GNU LGPL. See
;;;; http://www.gnu.org/licenses/lgpl.html.

(define-library (scheme-indent fill)
  
  (export fill)
  
  (import (scheme base))
  (import (scheme read))
  (import (scheme write))
  
  (import (prefix (scheme-indent string) @))
  
  (begin
    
    (define (fillable-comment? line)
      (let* ((i (@skip line #\space))
             (j (@skip line #\; i))
             (k (@skip line #\space j)))
        (and (@< i j) (@= j (@prev line k)))))
    
    (define (comment-words line)
      (let* ((i (@skip line #\space))
             (j (@skip line #\; i)))
        (and (@split line #\space j))))
    
    (define (comment-prefix line)
      (let* ((i (@skip line #\space))
             (j (@skip line #\; i)))
        (@substring line (@start line) j)))
    
    (define (fill-comment fill-width prefix words)
      (define (display-prefix)
        (display prefix))
      (define (display-word word)
        (display #\space)
        (display word))
      (let word-loop ((m 0) (words words))
        (cond
         ((null? words)
          (newline))
         ((zero? m)
          (display-prefix)
          (display-word (car words))
          (word-loop (+ (string-length prefix) 1 (string-length (car words)))
                     (cdr words)))
         ((<= (+ m 1 (string-length (car words))) fill-width)
          (display-word (car words))
          (word-loop (+ m 1 (string-length (car words)))
                     (cdr words)))
         (else
          (newline)
          (word-loop 0 words)))))
    
    (define (display-line line)
      (display line)
      (newline))
    
    (define (fill fill-width)
      (let line-loop ((line (read-line)))
        (cond
         ((eof-object? line))
         ((fillable-comment? line)
          (let ((prefix (comment-prefix line)))
            (let fill-loop ((words '()) (line line))
              (if (and (not (eof-object? line))
                       (fillable-comment? line))
                (fill-loop (append words (comment-words line))
                           (read-line))
                (begin
                  (fill-comment fill-width prefix words)
                  (line-loop line))))))
         (else
          (display-line line)
          (line-loop (read-line))))))))
